home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / fortran / toolpack.000 / toolpack / toolpack1.2 / tools / istjs / ISTJS.MAC.f
Encoding:
Text File  |  1989-03-04  |  14.4 KB  |  418 lines
  1. C---------------------------------------------------------
  2. C    TOOLPACK/1    Release: 3.1
  3. C---------------------------------------------------------
  4. C
  5. C  TOKEN STREAM BASED FORMAT STATEMENT 'CLUGGE' PROGRAM!
  6. C
  7. C  CHANGES FORMAT STATEMENTS ACCORDING TO STRANGE LOCAL REQUIREMENTS.
  8. C  DOES THE FOLLOWING;
  9. C     A) CONVERTS HOLLERITHS TO STRINGS
  10. C     B) CONVERTS X FIELDS TO STRINGS
  11. C     C) JOINS TOGETHER STRINGS ('A','B'  BECOMES  'AB')
  12. C     D) DELETES COMMAS PRECEDING AND FOLLOWING SLASHES
  13. C
  14. C  NOTE: THE TOOL IS FOOLED BY EMBEDDED COMMENTS!
  15. C
  16.       PROGRAM ISTJS
  17.  
  18.       INTEGER TKNIN, TKNOUT, CMTIN, CMTOUT
  19.       INTEGER TKNINM(81), TKNONM(81),
  20.      +        CMTINM(81), CMTONM(81),
  21.      +        OPTSTR(134)
  22.  
  23.       INTEGER OPEN, CREATE, GETARG, READCF
  24. C
  25.       CALL ZINIT
  26.  
  27.       IF (GETARG(1,TKNINM,81).EQ.-100) CALL NAMES(1,TKNINM)
  28.       IF (GETARG(2,CMTINM,81).EQ.-100) CALL NAMES(2,CMTINM)
  29.       IF (GETARG(3,TKNONM,81).EQ.-100) CALL NAMES(3,TKNONM)
  30.       IF (GETARG(4,CMTONM,81).EQ.-100) CALL NAMES(4,CMTONM)
  31.       IF (GETARG(5,OPTSTR,81).EQ.-100) CALL NAMES(5,OPTSTR)
  32. C
  33. C  OPEN AND CREATE THE REQUESTED FILES
  34. C
  35.       TKNIN =OPEN(TKNINM,0)
  36.       IF (TKNIN .EQ.-1)
  37.      +      CALL ERROR('ISTJS unable to open input token file.')
  38.       CMTIN =OPEN(CMTINM,0)
  39.       IF (CMTIN .EQ.-1)
  40.      +      CALL ERROR('ISTJS unable to open input comment file.')
  41.       TKNOUT=CREATE(TKNONM,1)
  42.       IF (TKNOUT.EQ.-1)
  43.      +      CALL ERROR('ISTJS unable to open output token file.')
  44.       CMTOUT=CREATE(CMTONM,1)
  45.       IF (CMTOUT.EQ.-1)
  46.      +      CALL ERROR('ISTJS unable to open output comment file.')
  47. C
  48. C  INTERPRET THE REQUESTED OPTIONS THEN PROCESS THE FILE.....
  49. C
  50.       CALL DOOPT(OPTSTR)
  51.       CALL TRNSFR(TKNIN, CMTIN, TKNOUT, CMTOUT)
  52. C
  53.       CALL ZMESS('[ISTJS: Normal Termination].', 1)
  54.       CALL ZQUIT(-2)
  55.       END
  56. C-----------------------------------------------------------
  57. C
  58. C  PROMPT THE USER FOR NAMES THAT HAVE NOT BEEN SUPPLIED.......
  59. C
  60.       SUBROUTINE NAMES (NUMB,PATH)
  61.  
  62.       INTEGER NUMB,PATH(*)
  63.  
  64.       INTEGER ZGTCMD
  65.       INTEGER JUNK,PROMPT(22, 5)
  66.  
  67.       DATA (PROMPT(I,1),I=1,19)/73,110,112,117,116,32,
  68.      +116,111,107,101,110,32,102,105,108,101,58,32,129/
  69.      +(PROMPT(I,2),I=1,21)/73,110,112,117,116,32,99,
  70.      +111,109,109,101,110,116,32,102,105,108,101,58,32,129/
  71.      +(PROMPT(I,3),I=1,20)/79,117,116,112,117,116,32,
  72.      +116,111,107,101,110,32,102,105,108,101,58,32,129/
  73.      +(PROMPT(I,4),I=1,22)/79,117,116,112,117,116,32,
  74.      +99,111,109,109,101,110,116,32,102,105,
  75.      +108,101,58,32,129/
  76.      +(PROMPT(I,5),I=1,10)/79,112,116,105,111,110,115,
  77.      +58,32,129/
  78.  
  79.       CALL ZPRMPT(PROMPT(1,NUMB))
  80.       JUNK=ZGTCMD(PATH,0)
  81.  
  82.       END
  83. C-----------------------------------------------------------
  84. C
  85. C  TOKEN STREAM EDITOR, COPIES THE INPUT TOKEN STREAM TO THE
  86. C  OUTPUT TOKEN STREAM JOINING STRINGS IN FORMATS
  87. C
  88.       SUBROUTINE TRNSFR(TKNIN, CMTIN, TKNOUT, CMTOUT)
  89.  
  90.       INTEGER TKNIN, CMTIN, TKNOUT, CMTOUT, TKNTYP, TKNLEN,
  91.      +        STATUS, I, J, DESCI, DESCO, POINT, C, COUNT,P,
  92.      +        MAXENT, MAXSIZ, ENTRY, OFFSET, CTOI, ITOC, LASTTK,
  93.      +        FROM, TO
  94.       PARAMETER (MAXENT = 128)
  95.       PARAMETER (MAXSIZ = 1322 * 3)
  96.       INTEGER TKNSTR(1322), BUFFER(maxsiz),
  97.      +        TYPES(MAXENT),LENTS(MAXENT),STRGS(MAXENT)
  98.       LOGICAL COMMAS(MAXENT)
  99.  
  100.       INTEGER LENGTH, ZSETP, ZSETR, ZPREPL, ZTKGTI, ZTKPTI
  101.       LOGICAL INFMT
  102.  
  103.       LOGICAL DOX, DOH,  DOJ, DOA
  104.       COMMON /OPTION/ DOX, DOH,  DOJ, DOA
  105.       SAVE /OPTION/
  106.  
  107. C---------------------------------------------------------
  108. C    TOOLPACK/1    Release: 2.4
  109. C---------------------------------------------------------
  110. C
  111. C  TKLAST = LAST TOKEN NUMBER
  112. C
  113.       INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
  114.      +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
  115.      +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
  116.      +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
  117.      +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
  118.      +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
  119.      +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
  120.      +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
  121.      +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
  122.      +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
  123.      +        TFMTKD,TENDKD,TERRKD,TKLAST
  124.       PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
  125.      +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
  126.      +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
  127.      +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
  128.      +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
  129.      +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
  130.      +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
  131.      +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
  132.      +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
  133.      +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
  134.      +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
  135.      +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
  136.      +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
  137.      +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
  138.      +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
  139.      +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
  140.      +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
  141.  
  142. C
  143. C  INITIALISE THE TOKEN STREAMS...................
  144. C
  145.       INFMT  = .FALSE.
  146.       DESCI = ZTKGTI(1, TKNIN, CMTIN)
  147.       DESCO = ZTKPTI(1, TKNOUT, CMTOUT)
  148.       IF(DESCI .LE. 0 .OR. DESCO .LE. 0) CALL
  149.      +   ERROR('[ISTJS] UNABLE TO INITIALSE TOKEN STREAMS.')
  150. C
  151. C  LOOP POINT.......
  152. C
  153.    10 CONTINUE
  154.         CALL ZGETTK(TKNTYP,TKNLEN,TKNSTR,DESCI,STATUS)
  155. C
  156. C  HANDLE FORMAT STATEMENTS
  157. C
  158. C  - READ IN ALL THE TOKENS, CONVERTING HOLLERITHS TO STRINGS
  159. C    IF REQUIRED.
  160. C  - PROCESS THE FORMAT STATEMENT
  161. C  - WRITE OUT ALL THE TOKENS, JOINING STRINGS TOGETHER
  162. C
  163.         IF(INFMT) THEN
  164.           POINT = 1
  165.           ENTRY = 0
  166. C
  167. C         READ IN THE TOKENS, CONVERT X AND H EDIT DESCRIPTORS TO STRINGS
  168. C         IF THESE ARE REQUIRED OPTIONS, DELETE ALL COMMA TOKENS........
  169. C
  170.    20     CONTINUE
  171.             IF(TKNTYP .EQ. TCMMNT) CALL REMARK(
  172.      +         '[ISTJS] Warning - embedded comment in FORMAT statment.')
  173.             IF(TKNTYP .NE. TCOMMA) THEN
  174.               ENTRY = ENTRY + 1
  175.               IF(ENTRY .GT. MAXENT) CALL ERROR
  176.      +          ('[ISTJS] FORMAT STATEMENT TOO COMPLEX.')
  177.               IF(DOH .AND. (TKNTYP .EQ. THCNST)) TKNTYP = TCCNST
  178.               IF(TKNLEN .GT. 0) THEN
  179.                 IF((TKNTYP.EQ.TFIELD .AND. TKNSTR(TKNLEN).EQ.120) .OR.
  180.      +             (TKNTYP.EQ.TFIELD .AND. TKNSTR(TKNLEN).EQ.88)) THEN
  181.                   I = 1
  182.                   LENTS(ENTRY) = CTOI(TKNSTR, I)
  183.                   IF(DOX) THEN
  184.                     TYPES(ENTRY) = TCCNST
  185.                     IF(POINT+LENTS(ENTRY)+1 .GT. MAXSIZ) CALL ERROR
  186.      +                ('[ISTJS] FORMAT STATEMENT TOO COMPLEX.')
  187.                     DO 21 I = 1, LENTS(ENTRY)
  188.                       BUFFER(POINT+I-1) = 32
  189.    21               CONTINUE
  190.                     STRGS(ENTRY) = POINT
  191.                     BUFFER(POINT+LENTS(ENTRY)) = 129
  192.                     POINT = POINT + LENTS(ENTRY) + 1
  193.                   ELSE
  194.                     TYPES(ENTRY) = -1
  195.                   ENDIF
  196.                 ELSE
  197.                   TYPES(ENTRY) = TKNTYP
  198.                   LENTS(ENTRY) = TKNLEN
  199.                   STRGS(ENTRY) = POINT
  200.                   COMMAS(ENTRY) = .FALSE.
  201.                   IF(POINT+LENTS(ENTRY)+1 .GT. MAXSIZ) CALL ERROR
  202.      +                ('[ISTJS] FORMAT STATEMENT TOO COMPLEX.')
  203.                   CALL SCOPY(TKNSTR, 1, BUFFER, POINT)
  204.                   POINT = POINT + TKNLEN + 1
  205.                 ENDIF
  206.               ELSE
  207.                 TYPES(ENTRY) = TKNTYP
  208.                 LENTS(ENTRY) = TKNLEN
  209.                 STRGS(ENTRY) = 1
  210.                 COMMAS(ENTRY) = .FALSE.
  211.               ENDIF
  212.             ELSE
  213.               COMMAS(ENTRY) = .TRUE.
  214.             ENDIF
  215.  
  216.             CALL ZGETTK(TKNTYP,TKNLEN,TKNSTR,DESCI,STATUS)
  217.           IF(TKNTYP .NE. TZEOS) GO TO 20
  218. C
  219. C         CONVERT ADJACENT X EDIT DESCRIPTORS
  220. C
  221.           IF(DOA) THEN
  222.             DO 25 I = 2, ENTRY-1
  223.               IF(TYPES(I) .EQ. -1) THEN
  224.                 IF(TYPES(I-1).EQ.TCCNST.OR.TYPES(I+1).EQ.TCCNST) THEN
  225.                   TYPES(I) = TCCNST
  226.                   IF(POINT+LENTS(I)+1 .GT. MAXSIZ) CALL ERROR
  227.      +                ('[ISTJS] UNABLE TO UNDO X EDIT DESCRIPTOR.')
  228.                   DO 26 J = 1, LENTS(I)
  229.                     BUFFER(POINT+J-1) = 32
  230.    26               CONTINUE
  231.                   STRGS(I) = POINT
  232.                   BUFFER(POINT+LENTS(I)) = 129
  233.                   POINT = POINT + LENTS(I) + 1
  234.                 ENDIF
  235.               ENDIF
  236.    25       CONTINUE
  237.           ENDIF
  238. C
  239. C         WORRY ABOUT BLANKS IN STRINGS.....
  240. C
  241.           IF(DOJ) THEN
  242.             DO 200 I = 1, ENTRY
  243.               IF(TYPES(I) .EQ. -1) THEN
  244.                 IF(I .GT. 2) THEN
  245.                   IF(TYPES(I-1).EQ.TCCNST) THEN
  246.                     COUNT = 0
  247.                     P = STRGS(I-1) + LENTS(I-1) - 1
  248.   205               CONTINUE
  249.                     IF(P-COUNT .GE. 1) THEN
  250.                       IF(BUFFER(P-COUNT) .EQ. 32) THEN
  251.                         COUNT = COUNT + 1
  252.                         GO TO 205
  253.                       ENDIF
  254.                     ENDIF
  255.                     BUFFER(P - COUNT + 1) = 129
  256.                     LENTS(I-1) = LENTS(I-1) - COUNT
  257.                     IF(LENTS(I-1) .EQ. 0) TYPES(I-1) = -2
  258.                     LENTS(I) = LENTS(I) + COUNT
  259.                   ENDIF
  260.                 ENDIF
  261.  
  262.                 IF(I+1 .LE. ENTRY) THEN
  263.                   IF(TYPES(I+1) .EQ. TCCNST) THEN
  264.                     COUNT = 0
  265.   235               CONTINUE
  266.                     IF(STRGS(I+1)+COUNT .LT. POINT) THEN
  267.                       C = BUFFER(STRGS(I+1)+COUNT)
  268.                       IF(C .EQ. 32) THEN
  269.                         COUNT = COUNT + 1
  270.                         GO TO 235
  271.                       ENDIF
  272.                     ENDIF
  273.                     LENTS(I+1) = LENTS(I+1) - COUNT
  274.                     STRGS(I+1) = STRGS(I+1) + COUNT
  275.                     IF(LENTS(I+1) .EQ. 0) TYPES(I+1) = -2
  276.                     LENTS(I) = LENTS(I) + COUNT
  277.                   ENDIF
  278.                 ENDIF
  279.               ENDIF
  280.  
  281.   200       CONTINUE
  282. C
  283. C           CLEAR DEAD WOOD
  284. C
  285.             TO = 0
  286.             DO 2999 I = 1, ENTRY
  287.               IF(TYPES(I) .GE. -1) THEN
  288.                 TO = TO + 1
  289.                 TYPES(TO) = TYPES(I)
  290.                 LENTS(TO) = LENTS(I)
  291.                 STRGS(TO) = STRGS(I)
  292.                 COMMAS(TO) = COMMAS(I)
  293.               ENDIF
  294.  2999       CONTINUE
  295.             ENTRY = TO
  296.           ENDIF
  297. C
  298. C         JOIN STRINGS AND X EDIT DESCRIPTORS
  299. C
  300.           I = 1
  301.    30     CONTINUE
  302.             IF(I .LT. ENTRY) THEN
  303.               IF((TYPES(I).EQ.TCCNST).AND.(TYPES(I+1).EQ.TCCNST)) THEN
  304.                 IF(POINT+LENTS(I)+LENTS(I+1)+1 .GT. MAXSIZ) CALL ERROR
  305.      +                ('[ISTJS] UNABLE TO JOIN STRINGS.')
  306.                 CALL SCOPY(BUFFER, STRGS(I), BUFFER, POINT)
  307.                 STRGS(I) = POINT
  308.                 POINT = POINT + LENTS(I)
  309.                 CALL SCOPY(BUFFER, STRGS(I+1), BUFFER, POINT)
  310.                 POINT = POINT + LENTS(I+1) + 1
  311.                 LENTS(I) = LENTS(I) + LENTS(I+1)
  312.                 DO 31 J = I+2,ENTRY
  313.                   TYPES(J-1) = TYPES(J)
  314.                   LENTS(J-1) = LENTS(J)
  315.                   STRGS(J-1) = STRGS(J)
  316.                   COMMAS(J-1) = COMMAS(J)
  317.    31           CONTINUE
  318.                 ENTRY = ENTRY - 1
  319.                 GO TO 30
  320.               ENDIF
  321.  
  322.               IF((TYPES(I) .EQ. -1).AND.(TYPES(I+1) .EQ. -1)) THEN
  323.                 LENTS(I) = LENTS(I) + LENTS(I+1)
  324.                 DO 32 J = I+2,ENTRY
  325.                   TYPES(J-1) = TYPES(J)
  326.                   LENTS(J-1) = LENTS(J)
  327.                   STRGS(J-1) = STRGS(J)
  328.                   COMMAS(J-1) = COMMAS(J)
  329.    32           CONTINUE
  330.                 ENTRY = ENTRY - 1
  331.                 GO TO 30
  332.               ENDIF
  333.             ENDIF
  334.             I = I + 1
  335.           IF(I .LT. ENTRY) GO TO 30
  336. C
  337. C         OUTPUT THE MODIFIED FORMAT STATEMENT
  338. C
  339.           LASTTK = TZEOS
  340.           DO 50 I = 1, ENTRY
  341.             IF(TYPES(I) .GT. 0) THEN
  342.               CALL ZPUTTK(TYPES(I),LENTS(I),BUFFER(STRGS(I)),DESCO)
  343.               LASTTK = TYPES(I)
  344.             ELSE IF(TYPES(I) .EQ. -1) THEN
  345.               C = ITOC(LENTS(I), TKNSTR, 10)
  346.               TKNSTR(C+1) = 88
  347.               TKNSTR(C+2) = 129
  348.               TKNLEN = C + 1
  349.               CALL ZPUTTK(TFIELD,TKNLEN,TKNSTR,DESCO)
  350.               LASTTK = TFIELD
  351.             ENDIF
  352.             IF(COMMAS(I)) THEN
  353.               IF(TYPES(I).EQ.TSLASH) GO TO 50
  354.               IF(I+1.EQ.ENTRY) GO TO 50
  355.               IF(I+1.LT.ENTRY) THEN
  356.                 IF(TYPES(I+1).EQ.TSLASH) GO TO 50
  357.                 IF(TYPES(I+1).EQ.TRPARN) GO TO 50
  358.               ENDIF
  359.               CALL ZPUTTK(TCOMMA,0,TKNSTR,DESCO)
  360.             ENDIF
  361.    50     CONTINUE
  362.           CALL ZPUTTK(TZEOS, 0, TKNSTR, DESCO)
  363.           INFMT = .FALSE.
  364. C
  365. C  HANDLE NON-FORMAT STATEMENTS, JUST PASS THEM STRAIGHT THROUGH
  366. C  WITHOUT PROCESSING, BUT LOOK FOR THE NEXT FORMAT STATEMENT!
  367. C
  368.         ELSE
  369.           IF(TKNTYP .EQ. TFORMA) INFMT = .TRUE.
  370.           CALL ZPUTTK(TKNTYP, TKNLEN, TKNSTR, DESCO)
  371.         ENDIF
  372.  
  373.       IF(TKNTYP .NE. TZEOF) GO TO 10
  374.  
  375.       END
  376. C-----------------------------------------------------------------------
  377. C
  378. C  INTERPRET THE REQUESTED OPTIONS......
  379. C
  380.       SUBROUTINE DOOPT(STRING)
  381.  
  382.       INTEGER I
  383.       INTEGER ZLOWER
  384.       INTEGER STRING(*)
  385.       LOGICAL DOX, DOH, DOJ, DOA
  386.       COMMON /OPTION/ DOX, DOH, DOJ, DOA
  387.       SAVE /OPTION/
  388.  
  389.       DOX = .FALSE.
  390.       DOA = .FALSE.
  391.       DOH = .TRUE.
  392.       DOJ = .TRUE.
  393.  
  394.       I = 1
  395.       CALL SKIPBL(STRING, I)
  396.  
  397.    10 CONTINUE
  398.         IF(STRING(I) .EQ. 129) THEN
  399.           RETURN
  400.         ELSE IF(ZLOWER(STRING(I)) .EQ. 120) THEN
  401.           DOX = .NOT. DOX
  402.         ELSE IF(ZLOWER(STRING(I)) .EQ. 104) THEN
  403.           DOH = .NOT. DOH
  404.         ELSE IF(ZLOWER(STRING(I)) .EQ. 106) THEN
  405.           DOJ = .NOT. DOJ
  406.         ELSE IF(ZLOWER(STRING(I)) .EQ. 97) THEN
  407.           DOA = .NOT. DOA
  408.         ELSE IF(STRING(I) .EQ. 45 .OR. STRING(I) .EQ. 32) THEN
  409.           CONTINUE
  410.         ELSE
  411.           CALL PUTCH(STRING(I), 2)
  412.           CALL ZMESS(': Unknown Option, Ignored.', 2)
  413.         ENDIF
  414.         I = I + 1
  415.       GO TO 10
  416.  
  417.       END
  418.